home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programmer Power Tools
/
Programmer Power Tools.iso
/
ada
/
vax.ada
< prev
Wrap
Text File
|
1988-03-25
|
4KB
|
115 lines
-- VAX.ADA Ver. 1.00 25-MAR-1988
-- Copyright 1988 John J. Herro
-- Software Innovations Technology
-- 1083 Mandarin Drive NE, Palm Bay, FL 32905-4706 (407)951-0233
--
-- Compile this before compiling ADA-TUTR.ADA with Vax Ada (tm, Digital
-- Equipment Corporation).
--
package CON_IO is
procedure GET (ITEM : out CHARACTER);
procedure GET (ITEM : in out STRING);
procedure PUT (ITEM : in CHARACTER);
procedure PUT (ITEM : in STRING);
procedure PUT_LINE (ITEM : in STRING);
procedure NEW_LINE;
procedure CLS; -- Clears the screen.
end CON_IO;
with CON_IO; use CON_IO;
procedure QGET(C : out CHARACTER) is
begin
GET(C);
end QGET;
with STARLET, SYSTEM; use STARLET, SYSTEM;
package body CON_IO is
CHAN : STARLET.CHANNEL_TYPE;
IOSB : SYSTEM.UNSIGNED_QUADWORD;
STAT : SYSTEM.UNSIGNED_LONGWORD;
procedure QIOW(STAT : out UNSIGNED_LONGWORD; EFN : in INTEGER;
CHAN : in CHANNEL_TYPE; FUNC : in SHORT_INTEGER;
IOSB : out UNSIGNED_QUADWORD; ASTADR : in INTEGER; ASTPRM : in INTEGER;
P1 : in out STRING; P2, P3 : in INTEGER; P4 : in UNSIGNED_QUADWORD;
P5, P6 : in INTEGER);
pragma INTERFACE(SYSTEM_LIBRARY, QIOW);
pragma IMPORT_VALUED_PROCEDURE(INTERNAL => QIOW, EXTERNAL => "SYS$QIOW",
PARAMETER_TYPES => (UNSIGNED_LONGWORD, INTEGER, CHANNEL_TYPE,
SHORT_INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER, STRING,
INTEGER, INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER),
MECHANISM => (VALUE, VALUE, VALUE, VALUE, REFERENCE, VALUE, REFERENCE,
REFERENCE, VALUE, REFERENCE, REFERENCE, REFERENCE, REFERENCE));
procedure GET(ITEM : out CHARACTER) is
S : STRING(1 .. 1);
begin
QIOW(STAT, 0, CHAN, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
ITEM := S(1);
end GET;
procedure PUT(ITEM : in CHARACTER) is
begin
PUT(ITEM & "");
end PUT;
procedure PUT(ITEM : in STRING) is
S : STRING(ITEM'RANGE) := ITEM;
begin
QIOW(STAT, 0, CHAN, 16#70#, IOSB, 0, 0, S, S'LENGTH, 0, (0,0), 0, 0);
end PUT;
procedure PUT_LINE(ITEM : in STRING) is
begin
PUT(ITEM & ASCII.CR & ASCII.LF);
end PUT_LINE;
procedure NEW_LINE is
begin
PUT(ASCII.CR & ASCII.LF);
end NEW_LINE;
procedure CLS is
begin
PUT(ASCII.ESC & "[H" & ASCII.ESC & "[J");
end CLS;
procedure GET(ITEM : in out STRING) is separate;
begin
STARLET.ASSIGN(STAT, "TT:", CHAN);
end CON_IO;
separate (CON_IO)
procedure GET(ITEM : in out STRING) is
INPUT : STRING(1 .. ITEM'LENGTH);
LEN : NATURAL := 0;
PLACE : POSITIVE := 1;
CHAR : CHARACTER := ' ';
begin
while CHAR /= ASCII.CR loop
GET(CHAR);
if CHAR = ASCII.CR then
NEW_LINE;
elsif CHAR = ASCII.DEL then
if PLACE > 1 then
PUT(ASCII.BS & INPUT(PLACE .. LEN) & ' ');
PLACE := PLACE - 1;
for I in 1 .. LEN + 1 - PLACE loop
PUT(ASCII.BS);
end loop;
LEN := LEN - 1;
INPUT(PLACE .. LEN) := INPUT(PLACE + 1 .. LEN + 1);
end if;
elsif LEN = ITEM'LENGTH and PLACE > ITEM'LENGTH then
PUT(ASCII.BEL);
else
PUT(CHAR);
INPUT(PLACE) := CHAR;
if LEN < PLACE then
LEN := LEN + 1;
end if;
PLACE := PLACE + 1;
end if;
end loop;
ITEM(ITEM'FIRST .. ITEM'FIRST + LEN - 1) := INPUT(1 .. LEN);
end GET;